home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / popmse.arc / POPMOUSE.SUB < prev   
Encoding:
Text File  |  1987-08-22  |  3.9 KB  |  162 lines
  1.   '***********************************************************************
  2.   SUB POPMOUSE(HEADER$,CHOICES%,SET%,ITEMS$(2),FRAME%,FORE%,BACK%,HFORE%,HBACK%,QUADRANT$,SHADOW%,CHOICE%) STATIC
  3.   DEFINT A-Z
  4.   DIM SCRN(2000)
  5.  
  6.   'Determine width of window from length of items
  7.  
  8.   WINDLEN=LEN(HEADER$)
  9.   FOR J=1 TO CHOICES
  10.     IF LEN(ITEMS$(SET,J)) > WINDLEN THEN WINDLEN=LEN(ITEMS$(SET,J))
  11.   NEXT J
  12.  
  13.   'If quadrant is in row:col format, extract row and column
  14.  
  15.   IF INSTR(QUADRANT$,":")<>0 THEN GOSUB GETORD: GOTO GO1
  16.  
  17.   'Determine position based on quadrant parameter and size of menu
  18.  
  19.   QUADRANT=VAL(QUADRANT$)
  20.   IF QUADRANT >4 OR QUADRANT <0 THEN QUADRANT=0
  21.   IF QUADRANT=0 THEN CROW=12: CCOL=40 ELSE ON QUADRANT GOSUB QUAD1,QUAD2,QUAD3,QUAD4
  22.   ULR=CROW-((CHOICES+2)/2-.5)
  23.   ULC=CCOL-((WINDLEN/2)-.5)
  24.   LRR=ULR+CHOICES+1
  25.   LRC=ULC+WINDLEN-1
  26.  
  27. GO1:    'Create Window for Menu
  28.  
  29.   WHERE=VARPTR(SCRN(0))
  30.   CALL SCRSAVE(WHERE)
  31.  
  32.   CALL MAKEWINDOW(ULC,ULR,LRC,LRR,LABEL$,FRAME,0,FORE,BACK,0)
  33.  
  34.   'Place header in window
  35.  
  36.   TEMPHDR$=SPACE$(WINDLEN)
  37.   IF LEN(HEADER$)<> WINDLEN THEN GOSUB PUTHDR
  38.  
  39.   CALL CALCATTR(HFORE,HBACK,ATTR)
  40.   ROW=ULR: COL=ULC
  41.   CALL XQPRINTD(HEADER$,ROW,COL,ATTR,0)
  42.   CALL CALCATTR(FORE,BACK,ATTR)
  43.   ROW=ULR+1: COL=ULC
  44.   DAT$=STRING$(WINDLEN,205)
  45.   CALL XQPRINTD(DAT$,ROW,COL,ATTR,0)
  46.  
  47.   'Place menu items in window
  48.  
  49.   FOR J=1 TO CHOICES
  50.     CALL CALCATTR(FORE,BACK,ATTR)
  51.     ROW=(ULR+1+J): COL=ULC
  52.     DAT$=ITEMS$(SET,J)
  53.     CALL XQPRINTD(DAT$,ROW,COL,ATTR,0)
  54.   NEXT J
  55.  
  56.   'Set current choice to menu item #1 and enter loop
  57.  
  58.   CLICK=0: CHOICE=1: CALL CLRKBD: GOSUB TON
  59.   CALL MMCHECK(MOUSE): IF MOUSE=0 GOTO POSITION
  60.   MOUSE=-1: LFTCOL=8*COL-8: TOPROW=8*ROW-8
  61.   RGTCOL=8*LRC-8: BOTROW=8*LRR-8
  62.   CALL MMSETRANGE(LFTCOL,TOPROW,RGTCOL,BOTROW)
  63.  
  64. POSITION:
  65.   GOSUB PROCESS: 'Update position of selection marker
  66.  
  67. LOPE:
  68.   IF MOUSE THEN GOSUB LOPEX: IF CLICK THEN GOTO DONE
  69.   GOSUB PRESS  'Get keypress
  70.   IF KP$=CHR$(13) OR KP$=CHR$(27) THEN GOTO DONE
  71.   GOTO LOPE
  72.  
  73.   'Check for left or right mouse button clicked
  74.   
  75. LOPEX:
  76.   CALL MMBUTTON(LFT,RGT)
  77.   IF RGT<>0 THEN CHOICE=0: CLICK=-1: RETURN
  78.   CALL MMGETLOC(MOUSECOL,MOUSEROW)
  79.   IF LFT<>0 THEN CHOICE=MOUSEROW\8-ULR: CLICK=-1: RETURN
  80.   IF CHOICE=MOUSEROW\8-ULR THEN RETURN
  81.   OLD=CHOICE: CHOICE=MOUSEROW\8-ULR: GOSUB PROCESS: RETURN
  82.  
  83.   'Check for keypress and sound error if not up arrow, down arrow, or return
  84.  
  85. PRESS: KP$=INKEY$
  86.   IF KP$="" THEN RETURN
  87.   IF KP$=CHR$(13) THEN RETURN
  88.   IF KP$=CHR$(27) THEN CHOICE=0: RETURN
  89.   IF LEN(KP$)=1 THEN SOUND 1000,1: SOUND 1500,2: SOUND 500,1: RETURN
  90.  
  91.   'Process down arrow keypress
  92.  
  93.   IF ASC(RIGHT$(KP$,1))=80 THEN
  94.     OLD=CHOICE: CHOICE=CHOICE+1
  95.     IF CHOICE > CHOICES THEN CHOICE=1
  96.     GOSUB PROCESS: RETURN
  97.   END IF
  98.  
  99.   'Process up arrow keypress
  100.  
  101.   IF ASC(RIGHT$(KP$,1))=72 THEN
  102.     OLD=CHOICE: CHOICE=CHOICE-1
  103.     IF CHOICE < 1 THEN CHOICE=CHOICES
  104.     GOSUB PROCESS: RETURN
  105.   END IF
  106.  
  107.   'Process error
  108.  
  109.   SOUND 1000,1: SOUND 1500,2: SOUND 500,1: RETURN
  110.  
  111. PROCESS:
  112.   'Turn off present selection
  113.   IF MOUSE THEN CALL MMCURSOROFF
  114.   CALL CALCATTR(FORE,BACK,ATTR)
  115.   ROW=(ULR+1+OLD): COL=ULC
  116.   DAT$=ITEMS$(SET,OLD)
  117.   CALL XQPRINTD(DAT$,ROW,COL,ATTR,0)
  118.  
  119.   'Turn on new selection
  120.  
  121. TON:   
  122.   CALL CALCATTR(BACK,FORE,ATTR)
  123.   ROW=(ULR+1+CHOICE): COL=ULC
  124.   DAT$=ITEMS$(SET,CHOICE)
  125.   CALL XQPRINTD(DAT$,ROW,COL,ATTR,0)
  126.   IF MOUSE THEN CALL MMSETLOC(LFTCOL,8*(CHOICE+ULR)): CALL MMCURSORON
  127.   RETURN
  128.  
  129. QUAD1:
  130.   CROW=7: CCOL=20
  131.   RETURN
  132. QUAD2:
  133.   CROW=7: CCOL=60
  134.   RETURN
  135. QUAD3:
  136.   CROW=18: CCOL=60
  137.   RETURN
  138. QUAD4:
  139.   CROW=18: CCOL=20
  140.   RETURN
  141.  
  142. GETORD:
  143.  
  144.   ULR=VAL(LEFT$(QUADRANT$,2))+1
  145.   ULC=VAL(RIGHT$(QUADRANT$,2))
  146.   LRR=ULR+CHOICES+1
  147.   LRC=ULC+WINDLEN-1
  148.   RETURN
  149.  
  150. PUTHDR:
  151.  
  152.   PAD=(WINDLEN/2)-(LEN(HEADER$)/2)-.5
  153.   MID$(TEMPHDR$,PAD+1,LEN(HEADER$))=HEADER$
  154.   HEADER$=TEMPHDR$
  155.   RETURN
  156.  
  157. DONE:
  158.   IF MOUSE THEN CALL MMCURSOROFF
  159.   CALL SCRREST(WHERE)
  160.  
  161.   END SUB
  162.